Usenet 1993 July

home *** CD-ROM | disk | FTP | other *** search

/ Usenet 1993 July / InfoMagic USENET CD-ROM July 1993.ISO / sources / unix / volume26 / veos-2.0 / part06 < prev next >

Wrap

Text File | 1993-04-25 | 82.9 KB | 3,040 lines

Newsgroups: comp.sources.unix From: voodoo@hitl.washington.edu (Geoffery Coco) Subject: v26i189: veos-2.0 - The Virtual Environment Operating Shell, V2.0, Part06/16 Sender: unix-sources-moderator@vix.com Approved: paul@vix.com Submitted-By: voodoo@hitl.washington.edu (Geoffery Coco) Posting-Number: Volume 26, Issue 189 Archive-Name: veos-2.0/part06 #! /bin/sh # This is a shell archive. Remove anything before this line, then unpack # it by saving it into a file and typing "sh file". To overwrite existing # files, type "sh file -c". You can also feed this as standard input via # unshar, or by typing "sh <file", e.g.. If this archive is complete, you # will see the following message at the end: # "End of archive 6 (of 16)." # Contents: src/utils/xv_utils.c src/xlisp/xcore/c/unixstuff.c # src/xlisp/xcore/c/xlfio.c src/xlisp/xcore/c/xlisp.h # src/xlisp/xcore/c/xlmath.c src/xlisp/xcore/c/xlstruct.c # Wrapped by vixie@efficacy.home.vix.com on Sun Apr 25 23:10:37 1993 PATH=/bin:/usr/bin:/usr/ucb ; export PATH if test -f 'src/utils/xv_utils.c' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'src/utils/xv_utils.c'\" else echo shar: Extracting \"'src/utils/xv_utils.c'\" $13040 characters$ sed "s/^X//" >'src/utils/xv_utils.c' <<'END_OF_FILE' X/**************************************************************************************** X * * X * file: xv_utils.c * X * * X * Sundry lisp utils for the veos project * X * * X * creation: March 28, 1991 * X * * X * * X * Includes utilities by: * X * * X * Geoff Coco * X * Dav Lion * X * Andy McDonald * X * Fran Taylor * X * * X ****************************************************************************************/ X X/**************************************************************************************** X * Copyright (C) 1992 Human Interface Technology Lab, Seattle * X ****************************************************************************************/ X X#include "xlisp.h" X#include "world.h" X#include <math.h> X#include <sys/time.h> X Xextern LVAL true; X Xtypedef float TMatrix[4][4]; Xtypedef float TTriple[3]; Xtypedef float TVector[4]; X XLVAL ReverseList(); Xboolean IsTripleElt(); X X X/****************************************************************************************/ XLVAL read_time () X{ X struct timeval t; X double now, diff; X static double then = 0.0; X int err; X X err = gettimeofday( &t, 0); X/* X fprintf( stderr, "%d %d\n", t.tv_sec, t.tv_usec); X*/ X if( err == -1) X xlerror( "read-time: timer barfed"); X else X { X now = (double)t.tv_sec + (double)t.tv_usec / 1000000.0; X/* X fprintf( stderr, "%f %f\n", now, then); X*/ X diff = now - then; X then = now; X } X return cvflonum( diff); X} X/****************************************************************************************/ X X X X/**************************************************************************************** X *.native_sprintf -- data conversion. * X ****************************************************************************************/ X XLVAL native_sprintf() X{ X str255 sLocal; X X util_sprintf(sLocal); X X return(cvstring(sLocal)); X X } /* native_sprintf */ X/****************************************************************************************/ X X X/**************************************************************************************** X *.native_printf -- data conversion. * X ****************************************************************************************/ X XLVAL native_printf() X{ X str255 sLocal; X X util_sprintf(sLocal); X fprintf(stderr, "%s\n", sLocal); X X return(true); X X } /* native_printf */ X/****************************************************************************************/ X X X X/**************************************************************************************** X *.native_printf1 -- data conversion. * X ****************************************************************************************/ X XLVAL native_printf1() X{ X str255 sLocal; X X util_sprintf(sLocal); X fprintf(stderr, "%s", sLocal); X X return(true); X X } /* native_printf1 */ X/****************************************************************************************/ X X X/****************************************************************************************/ XTVeosErr util_sprintf(sDest) X char *sDest; X{ X LVAL pXElt; X str63 sZoot; X X sDest[0] = '\0'; X X while (moreargs()) { X X pXElt = xlgetarg(); X X if (!null(pXElt)) { X X switch (ntype(pXElt)) { X X case FIXNUM: X sprintf(sZoot, "%d", getfixnum(pXElt)); X strcat(sDest, sZoot); X break; X X case FLONUM: X sprintf(sZoot, "%.2f", getflonum(pXElt)); X strcat(sDest, sZoot); X break; X X case STRING: X strcat(sDest, (char *) getstring(pXElt)); X break; X X default: X break; X } X } X } X X return(VEOS_SUCCESS); X X } /* util_sprintf */ X/****************************************************************************************/ X X X X X/**************************************************************************************** X *.native_sscanf -- data conversion. * X ****************************************************************************************/ X XLVAL native_sscanf() X{ X LVAL pData; X LVAL pList, pXElt; X char *pDataFinger; X X xlsave1(pList); X xlsave1(pXElt); X X pData = xlgastring(); X xllastarg(); X X pDataFinger = (char *) getstring(pData); X while (pDataFinger) { X X /** skip white space **/ X X while (pDataFinger[0] == ' ') X pDataFinger ++; X X if (pDataFinger[0] == '\0') X break; X X /** StrToXElt() looks for ' ' or '\0' as delimiter **/ X X StrToXElt(pDataFinger, &pXElt); X pList = cons(pXElt, pList); X X pDataFinger = strchr(pDataFinger, ' '); X } X X pList = ReverseList(pList); X X xlpopn(2); X X return(pList); X X } /* native_sscanf */ X/****************************************************************************************/ X X X X X/****************************************************************************************/ XTVeosErr XVUtils_LoadPrims() X{ X Xform_LoadPrims(); X X#define UTIL_LOAD X#include "xv_utils.h" X#undef UTIL_LOAD X X } X/****************************************************************************************/ X X X X X/**************************************************************************************** X * StrToXElt */ X XTVeosErr StrToXElt(sData, hXElt) X char *sData; X LVAL *hXElt; X{ X TVeosErr iErr; X char *pFinger, cSave; X int iDots, iChars, iDigits; X int iType; X LVAL pXElt; X float fVal; X int iVal; X X iErr = VEOS_SUCCESS; X iType = FREE; X iDigits = iDots = iChars = 0; X X xlsave1(pXElt); X X pFinger = sData; X X /** minus not necessarily a character **/ X X if (pFinger[0] == '-') X pFinger ++; X X X while (TRUE) { X X if (pFinger[0] == ' ' || pFinger[0] == '\0') { X break; X } X X if (isdigit(pFinger[0])) X iDigits ++; X else if (pFinger[0] == '.') X iDots ++; X else X iChars ++; X X pFinger ++; X } X X cSave = pFinger[0]; X pFinger[0] = '\0'; X X if (iChars > 0 || iDots > 1) X pXElt = cvstring(sData); X X else { X if (iDots == 0) { X sscanf(sData, "%d", &iVal); X pXElt = cvfixnum(iVal); X } X else { X sscanf(sData, "%f", &fVal); X pXElt = cvflonum(fVal); X } X } X X pFinger[0] = cSave; X X *hXElt = pXElt; X X xlpop(); X X return(iErr); X X } /* StrToXElt */ X/****************************************************************************************/ X X X X/****************************************************************************************/ XLVAL ReverseList(pList) X LVAL pList; X{ X LVAL pSave, pXElt; X X xlsave1(pSave); X xlsave1(pXElt); X X while (!null(pList)) { X pSave = cdr(pList); X rplacd(pList, pXElt); X pXElt = pList; X pList = pSave; X } X X xlpopn(2); X X return(pXElt); X X } /* Native_ReverseList */ X/****************************************************************************************/ X X X X/****************************************************************************************/ Xboolean IsQuatElt(pXElt) X LVAL pXElt; X{ X return(vectorp(pXElt) && X getsz(pXElt) == 2 && X floatp(getelement(pXElt, 0)) && X IsTripleElt(getelement(pXElt, 1))); X X } /* IsQuatElt */ X/****************************************************************************************/ X X X/****************************************************************************************/ Xboolean IsMatrixElt(pXElt) X LVAL pXElt; X{ X return(vectorp(pXElt) && getsz(pXElt) == 16); X X } /* IsMatrixElt */ X/****************************************************************************************/ X X X/****************************************************************************************/ Xvoid XVect2Mat(pXElt, pMat) X LVAL pXElt; X TMatrix pMat; X{ X int iEltIndex; X X /** assume sanity is checked **/ X for (iEltIndex = 0; iEltIndex < 16; iEltIndex ++) X pMat[iEltIndex / 4][iEltIndex % 4] = getflonum(getelement(pXElt, iEltIndex)); X X } /* XVect2Mat */ X/****************************************************************************************/ X X X/****************************************************************************************/ XLVAL Mat2XVect(pMat) X TMatrix pMat; X{ X LVAL pXElt; X int iEltIndex; X X xlsave1(pXElt); X X /** assume sanity is checked **/ X pXElt = newvector(16); X X for (iEltIndex = 0; iEltIndex < 16; iEltIndex ++) X setelement(pXElt, iEltIndex, cvflonum(pMat[iEltIndex / 4][iEltIndex % 4])); X X xlpop(); X X return(pXElt); X X } /* Mat2XVect */ X/****************************************************************************************/ X X X/****************************************************************************************/ Xboolean IsTripleElt(pXElt) X LVAL pXElt; X{ X return(vectorp(pXElt) && getsz(pXElt) == 3); X X } /* IsTripleElt */ X/****************************************************************************************/ X X X/****************************************************************************************/ Xvoid XVect2Tri(pXElt, pTri) X LVAL pXElt; X TTriple pTri; X{ X /** assume sanity is checked **/ X X pTri[0] = getflonum(getelement(pXElt, 0)); X pTri[1] = getflonum(getelement(pXElt, 1)); X pTri[2] = getflonum(getelement(pXElt, 2)); X X } /* XVect2Tri */ X/****************************************************************************************/ X X X/****************************************************************************************/ XLVAL Tri2XVect(pTri) X TTriple pTri; X{ X LVAL pXElt; X X xlsave1(pXElt); X X /** assume sanity is checked **/ X pXElt = newvector(3); X X setelement(pXElt, 0, cvflonum(pTri[0])); X setelement(pXElt, 1, cvflonum(pTri[1])); X setelement(pXElt, 2, cvflonum(pTri[2])); X X xlpop(); X X return(pXElt); X X } /* Tri2XVect */ X/****************************************************************************************/ X X X/****************************************************************************************/ Xvoid XVect2Quat(pXElt, pVect) X LVAL pXElt; X TVector pVect; X{ X LVAL pTri; X X /** assume sanity is checked **/ X X pVect[0] = getflonum(getelement(pXElt, 0)); X X pTri = getelement(pXElt, 1); X pVect[1] = getflonum(getelement(pTri, 0)); X pVect[2] = getflonum(getelement(pTri, 1)); X pVect[3] = getflonum(getelement(pTri, 2)); X X } /* XVect2Quat */ X/****************************************************************************************/ X X X/****************************************************************************************/ XLVAL Quat2XVect(pVect) X TVector pVect; X{ X LVAL pXElt, pMid; X X /** assume sanity is checked **/ X X xlsave1(pXElt); X xlsave1(pMid); X X pMid = newvector(3); X X setelement(pMid, 0, cvflonum(pVect[1])); X setelement(pMid, 1, cvflonum(pVect[2])); X setelement(pMid, 2, cvflonum(pVect[3])); X X pXElt = newvector(2); X X setelement(pXElt, 0, cvflonum(pVect[0])); X setelement(pXElt, 1, pMid); X X xlpopn(2); X X return(pXElt); X X } /* Quat2XVect */ X/****************************************************************************************/ X X X X/****************************************************************************************/ Xvoid XLispMat2Mat(lMat, pMat) X LVAL lMat; X float pMat[4][4]; X{ X pMat[0][0] = getflonum(getelement(lMat, 0)); X pMat[0][1] = getflonum(getelement(lMat, 1)); X pMat[0][2] = getflonum(getelement(lMat, 2)); X pMat[0][3] = getflonum(getelement(lMat, 3)); X X pMat[1][0] = getflonum(getelement(lMat, 4)); X pMat[1][1] = getflonum(getelement(lMat, 5)); X pMat[1][2] = getflonum(getelement(lMat, 6)); X pMat[1][3] = getflonum(getelement(lMat, 7)); X X pMat[2][0] = getflonum(getelement(lMat, 8)); X pMat[2][1] = getflonum(getelement(lMat, 9)); X pMat[2][2] = getflonum(getelement(lMat, 10)); X pMat[2][3] = getflonum(getelement(lMat, 11)); X X pMat[3][0] = getflonum(getelement(lMat, 12)); X pMat[3][1] = getflonum(getelement(lMat, 13)); X pMat[3][2] = getflonum(getelement(lMat, 14)); X pMat[3][3] = getflonum(getelement(lMat, 15)); X X X }/*LispMat2Mat*/ X/****************************************************************************************/ X X X/****************************************************************************************/ Xvoid XMat2LispMat(pMat, lMat) X float pMat[4][4]; X LVAL lMat; X{ X X stuff_flonum(lMat, 0, pMat[0][0]); X stuff_flonum(lMat, 1, pMat[0][1]); X stuff_flonum(lMat, 2, pMat[0][2]); X stuff_flonum(lMat, 3, pMat[0][3]); X X stuff_flonum(lMat, 4, pMat[1][0]); X stuff_flonum(lMat, 5, pMat[1][1]); X stuff_flonum(lMat, 6, pMat[1][2]); X stuff_flonum(lMat, 7, pMat[1][3]); X X stuff_flonum(lMat, 8, pMat[2][0]); X stuff_flonum(lMat, 9, pMat[2][1]); X stuff_flonum(lMat, 10, pMat[2][2]); X stuff_flonum(lMat, 11, pMat[2][3]); X X stuff_flonum(lMat, 12, pMat[3][0]); X stuff_flonum(lMat, 13, pMat[3][1]); X stuff_flonum(lMat, 14, pMat[3][2]); X stuff_flonum(lMat, 15, pMat[3][3]); X X }/*Mat2LispMat*/ X/****************************************************************************************/ X END_OF_FILE if test 13040 -ne `wc -c <'src/utils/xv_utils.c'`; then echo shar: \"'src/utils/xv_utils.c'\" unpacked with wrong size! fi # end of 'src/utils/xv_utils.c' fi if test -f 'src/xlisp/xcore/c/unixstuff.c' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'src/xlisp/xcore/c/unixstuff.c'\" else echo shar: Extracting \"'src/xlisp/xcore/c/unixstuff.c'\" $14087 characters$ sed "s/^X//" >'src/xlisp/xcore/c/unixstuff.c' <<'END_OF_FILE' X/* -*-C-*- X******************************************************************************** X* X* File: unixstuff.c X* RCS: $Header: unixstuff.c,v 1.3 89/11/25 05:12:16 mayer Exp $ X* Description: UNIX-Specific interfaces for XLISP X* Author: David Michael Betz; Niels Mayer X* Created: X* Modified: Sat Nov 25 05:12:04 1989 (Niels Mayer) mayer@hplnpm X* Language: C X* Package: N/A X* Status: X11r4 contrib tape release X* X* WINTERP 1.0 Copyright 1989 Hewlett-Packard Company (by Niels Mayer). X* XLISP version 2.1, Copyright (c) 1989, by David Betz. X* X* Permission to use, copy, modify, distribute, and sell this software and its X* documentation for any purpose is hereby granted without fee, provided that X* the above copyright notice appear in all copies and that both that X* copyright notice and this permission notice appear in supporting X* documentation, and that the name of Hewlett-Packard and David Betz not be X* used in advertising or publicity pertaining to distribution of the software X* without specific, written prior permission. Hewlett-Packard and David Betz X* make no representations about the suitability of this software for any X* purpose. It is provided "as is" without express or implied warranty. X* X* HEWLETT-PACKARD AND DAVID BETZ DISCLAIM ALL WARRANTIES WITH REGARD TO THIS X* SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, X* IN NO EVENT SHALL HEWLETT-PACKARD NOR DAVID BETZ BE LIABLE FOR ANY SPECIAL, X* INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM X* LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE X* OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR X* PERFORMANCE OF THIS SOFTWARE. X* X* See ./winterp/COPYRIGHT for information on contacting the authors. X* X* Please send modifications, improvements and bugfixes to mayer@hplabs.hp.com X* Post XLISP-specific questions/information to the newsgroup comp.lang.lisp.x X* X******************************************************************************** X*/ Xstatic char rcs_identity[] = "@(#)$Header: unixstuff.c,v 1.3 89/11/25 05:12:16 mayer Exp $"; X X X#include "xlisp.h" X X/****************************************************************************** X * Prim_POPEN - start a process and open a pipe for read/write X * (code stolen from xlfio.c:xopen()) X * X * syntax: (popen <command line> :direction <direction>) X * <command line> is a string to be sent to the subshell (sh). X * <direction> is either :input (to read from the pipe) or X * :output (to write to the pipe). X * (:input is the default) X * X * Popen returns a stream, or NIL if files or processes couldn't be created. X * The success of the command execution can be checked by examining the X * return value of pclose. X * X * Added to XLISP by Niels Mayer X ******************************************************************************/ XLVAL Prim_POPEN() X{ X extern LVAL k_direction, k_input, k_output; X char *name,*mode; X FILE *fp; X LVAL dir; X X /* get the process name and direction */ X name = (char *) getstring(xlgastring()); X if (!xlgetkeyarg(k_direction, &dir)) X dir = k_input; X X /* get the mode */ X if (dir == k_input) X mode = "r"; X else if (dir == k_output) X mode = "w"; X else X xlerror("bad direction",dir); X X /* try to open the file */ X return ((fp = popen(name,mode)) ? cvfile(fp) : NIL); X} X X X/****************************************************************************** X * Prim_PCLOSE - close a pipe opened by Prim_POPEN(). X * (code stolen from xlfio.c:xclose()) X * X * syntax: (pclose <stream>) X * <stream> is a stream created by popen. X * returns T if the command executed successfully, otherwise, X * returns the exit status of the opened command. X * X * Added to XLISP by Niels Mayer X ******************************************************************************/ XLVAL Prim_PCLOSE() X{ X extern LVAL true; X LVAL fptr; X int result; X X /* get file pointer */ X fptr = xlgastream(); X xllastarg(); X X /* make sure the file exists */ X if (getfile(fptr) == NULL) X xlfail("file not open"); X X /* close the pipe */ X result = pclose(getfile(fptr)); X X if (result == -1) X xlfail("<stream> has not been opened with popen"); X X setfile(fptr,NULL); X X /* return T if success (exit status 0), else return exit status */ X return (result ? cvfixnum(result) : true); X} X X X/****************************************************************************** X * Prim_SYSTEM - run a process, sending output (if any) to stdout/stderr X * X * syntax: (system <command line>) X * <command line> is a string to be sent to the subshell (sh). X * X * Returns T if the command executed succesfully, otherwise returns the X * integer shell exit status for the command. X * X * Added to XLISP by Niels Mayer X ******************************************************************************/ XLVAL Prim_SYSTEM() X{ X extern LVAL true; X extern int sys_nerr; X extern char *sys_errlist[]; X extern int errno; X LVAL command; X int result; X char temptext[1024]; X X /* get shell command */ X command = xlgastring(); X xllastarg(); X X /* run the process */ X result = system((char *) getstring(command)); X X if (result == -1) { /* if a system error has occured */ X if (errno < sys_nerr) X (void) sprintf(temptext, "Error in system(3S): %s\n", sys_errlist[errno]); X else X (void) strcpy(temptext, "Error in system(3S): unknown error\n"); X xlfail(temptext); X } X X /* return T if success (exit status 0), else return exit status */ X return (result ? cvfixnum(result) : true); X} X X X/****************************************************************************** X * (FSCANF-FIXNUM <stream> <scanf-format>) X * This routine calls fscanf(3s) on a <stream> that was previously openend X * via open or popen. It will not work on an USTREAM. X * <scanf-format> is a format string containing a single conversion X * directive that will result in an integer valued conversion. X * %d, %u, %o, %x, %ld, %lu, %lo and %lx style conversions X * are acceptable for this routine. X * WARNING: specifying a <scanf-format> that will result in the conversion X * of a result larger than sizeof(long) will result in corrupted memory and X * core dumps. X * X * This routine will return an FIXNUM if fscanf() returns 1 (i.e. if X * the one expected conversion has succeeded. It will return NIL if the X * conversion wasn't successful, or if EOF was reached. X ******************************************************************************/ XLVAL Prim_FSCANF_FIXNUM() X{ X LVAL lval_stream; X char* fmt; X long result; X X lval_stream = xlgastream(); X if (getfile(lval_stream) == NULL) X xlerror("File not opened.", lval_stream); X fmt = (char *) getstring(xlgastring()); X xllastarg(); X X result = 0L; /* clear it out hibits incase short is written */ X /* if scanf returns result <1 then an error or eof occured. */ X if (fscanf(getfile(lval_stream), fmt, &result) < 1) X return (NIL); X else X return (cvfixnum((FIXTYPE) result)); X} X X X/****************************************************************************** X * (FSCANF-STRING <stream> <scanf-format>) X * This routine calls fscanf(3s) on a <stream> that was previously openend X * via open or popen. It will not work on an USTREAM. X * <scanf-format> is a format string containing a single conversion X * directive that will result in a string valued conversion. X * %s, %c, and %[...] style conversions are acceptable for X * this routine. X * WARNING: specifying a <scanf-format> that will result in the conversion X * of a result larger than 1024 characters will result in corrupted X * memory and core dumps. X * X * This routine will return a string if fscanf() returns 1 (i.e. if X * the one expected conversion has succeeded. It will return NIL if the X * conversion wasn't successful, or if EOF was reached. X ******************************************************************************/ XLVAL Prim_FSCANF_STRING() X{ X LVAL lval_stream; X char* fmt; X char result[BUFSIZ]; X X X lval_stream = xlgastream(); X if (getfile(lval_stream) == NULL) X xlerror("File not opened.", lval_stream); X fmt = (char *) getstring(xlgastring()); X xllastarg(); X X result[0] = result[1] = '\0'; /* if the conversion is %c, then fscanf X doesn't null terminate the string, X so do it just incase */ X X /* if scanf returns result <1 then an error or eof occured. */ X if (fscanf(getfile(lval_stream), fmt, result) < 1) X return (NIL); X else X return (cvstring(result)); X} X X X/****************************************************************************** X * (FSCANF-FLONUM <stream> <scanf-format>) X * This routine calls fscanf(3s) on a <stream> that was previously openend X * via open or popen. It will not work on an USTREAM. X * <scanf-format> is a format string containing a single conversion X * directive that will result in an FLONUM valued conversion. X * %e %f or %g are valid conversion specifiers for this routine. X * X * WARNING: specifying a <scanf-format> that will result in the conversion X * of a result larger than sizeof(float) will result in corrupted memory and X * core dumps. X * X * This routine will return a FLONUM if fscanf() returns 1 (i.e. if X * the one expected conversion has succeeded. It will return NIL if the X * conversion wasn't successful, or if EOF was reached. X ******************************************************************************/ XLVAL Prim_FSCANF_FLONUM() X{ X LVAL lval_stream; X char* fmt; X FILE * fp; X float result; X X lval_stream = xlgastream(); X if (getfile(lval_stream) == NULL) X xlerror("File not opened.", lval_stream); X fmt = (char *) getstring(xlgastring()); X xllastarg(); X X /* if scanf returns result <1 then an error or eof occured. */ X if (fscanf(getfile(lval_stream), fmt, &result) < 1) X return (NIL); X else X return (cvflonum((FLOTYPE) result)); X} X X X/******************************************************************************/ X/******************************************************************************/ X/******************************************************************************/ X/* -- stuff.c -- operating system specific routines */ X/* -- Written by dbetz for XLISP 2.0 */ X/* -- Copied by EFJohnson from a BIX message */ X/* -- Unix System V */ X X#define LBSIZE 200 X X/* -- external variables */ Xextern FILE *tfp; X X/* -- local variables */ Xstatic long rseed = 1L; X Xstatic char lbuf[LBSIZE]; Xstatic int lindex; Xstatic int lcount; X X X/* -- osinit - initialize */ Xosinit(banner) Xchar *banner; X{ X printf("%s\n", banner ); X lindex = 0; X lcount = 0; X} X X/* -- osfinish - clean up before returning to the operating system */ Xosfinish() X{ X} X X X/* -- xoserror - print an error message */ Xxoserror(msg) X Xchar *msg; X X{ X printf( "error: %s\n", msg ); X} X X X/* -- osrand - return a random number between 0 and n-1 */ Xint osrand(n) X Xint n; X X{ X long k1; X X /* -- make sure we don't get stuck at zero */ X if ( rseed == 0L ) rseed = 1L; X X /* -- algorithm taken from Dr Dobbs Journal, Nov. 1985, page 91 */ X k1 = rseed / 127773L; X if ( ( rseed = 16807L * (rseed - k1 * 127773L) -k1 * 2836L) < 0L ) X rseed += 2147483647L; X X /* -- return a random number between 0 and n-1 */ X return( (int) (rseed % (long) n ) ); X} X X X X/* -- osaopen -- open an ascii file */ XFILE *osaopen( name, mode ) Xchar *name, *mode; X{ X return( fopen( name, mode ) ); X} X X X X/* -- osbopen -- open a binary file */ XFILE *osbopen( name, mode ) Xchar *name, *mode; X{ X return( fopen( name, mode ) ); X} X X X/* -- osclose -- close a file */ Xint osclose( fp ) XFILE *fp; X{ X return( fclose( fp ) ); X} X X X/* -- osagetc - get a character from an ASCII file */ Xint osagetc( fp ) XFILE *fp; X{ X return( getc(fp) ); X} X X/* -- osaputc - put a character to an ASCII file */ Xint osaputc( ch, fp ) Xint ch; XFILE *fp; X{ X return( putc( ch, fp ) ); X} X X X X/* -- osbgetc - get a character from a binary file */ Xint osbgetc( fp ) XFILE *fp; X{ X return( getc(fp) ); X} X X/* -- osbputc - put a character to a binary file */ Xint osbputc( ch, fp ) Xint ch; XFILE *fp; X{ X return( putc( ch, fp ) ); X} X X X/* -- ostgetc - get a character from the terminal */ Xint ostgetc() X{ X while(--lcount < 0 ) X { X if ( fgets(lbuf,LBSIZE,stdin) == NULL ) X return( EOF ); X if ( tfp ) X fputs( lbuf, tfp ); X lcount = strlen( lbuf ); X lindex = 0; X } X X return( lbuf[lindex++] ); X} X X X/* -- ostputc - put a character to the terminal */ Xostputc( ch ) Xint ch; X{ X /* -- check for control characters */ X oscheck(); X X /* -- output the character */ X putchar( ch ); X X /* -- output the char to the transcript file */ X if ( tfp ) X osaputc( ch, tfp ); X} X X X X X/* -- osflush - flush the terminal input buffer */ Xosflush() X{ X lindex = lcount = 0; X} X X X/* -- oscheck - check for control characters during execution */ Xoscheck() X{ X} X X X/* -- ossymbols - enter os-specific symbols */ Xossymbols() X{ X} X X/****************************************************************************** X * xosgetenv - get string from environment X * X * syntax: (getenv key) X * <key> is something like TERM to look up in the unix environment. X * X * If "<key>=<val> is not found in the environment, xosgetenv returns NIL. X * Otherwise, xosgetenv returns a list of strings, one for each ':'-delimited X * component of <val>. X * X * Added to XLISP by Jeff Prothero X ******************************************************************************/ XLVAL envget( key_as_asciz ) Xchar* key_as_asciz; X{ X extern char* getenv(); X LVAL result; X char *val_as_asciz = getenv( key_as_asciz ); X xlsave1( result ); X if (val_as_asciz != NULL) { X do { X char buf[ 1024 ]; X char *dst = buf; X while (*val_as_asciz && *val_as_asciz != ':') { X *dst++ = *val_as_asciz++; X } X *dst = '\0'; X result = cons( cvstring(buf), result ); X } while (*val_as_asciz++); X } X xlpop(); X return result; X} XLVAL xosenvget() X{ X char *key_as_asciz = (char *) getstring(xlgastring()); X xllastarg(); X return envget( key_as_asciz ); X} END_OF_FILE if test 14087 -ne `wc -c <'src/xlisp/xcore/c/unixstuff.c'`; then echo shar: \"'src/xlisp/xcore/c/unixstuff.c'\" unpacked with wrong size! fi # end of 'src/xlisp/xcore/c/unixstuff.c' fi if test -f 'src/xlisp/xcore/c/xlfio.c' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'src/xlisp/xcore/c/xlfio.c'\" else echo shar: Extracting \"'src/xlisp/xcore/c/xlfio.c'\" $11944 characters$ sed "s/^X//" >'src/xlisp/xcore/c/xlfio.c' <<'END_OF_FILE' X/* -*-C-*- X******************************************************************************** X* X* File: xlfio.c X* RCS: $Header: xlfio.c,v 1.4 89/11/25 05:24:44 mayer Exp $ X* Description: xlisp file i/o X* Author: David Michael Betz X* Created: X* Modified: Sat Nov 25 05:24:25 1989 (Niels Mayer) mayer@hplnpm X* Language: C X* Package: N/A X* Status: X11r4 contrib tape release X* X* WINTERP 1.0 Copyright 1989 Hewlett-Packard Company (by Niels Mayer). X* XLISP version 2.1, Copyright (c) 1989, by David Betz. X* X* Permission to use, copy, modify, distribute, and sell this software and its X* documentation for any purpose is hereby granted without fee, provided that X* the above copyright notice appear in all copies and that both that X* copyright notice and this permission notice appear in supporting X* documentation, and that the name of Hewlett-Packard and David Betz not be X* used in advertising or publicity pertaining to distribution of the software X* without specific, written prior permission. Hewlett-Packard and David Betz X* make no representations about the suitability of this software for any X* purpose. It is provided "as is" without express or implied warranty. X* X* HEWLETT-PACKARD AND DAVID BETZ DISCLAIM ALL WARRANTIES WITH REGARD TO THIS X* SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, X* IN NO EVENT SHALL HEWLETT-PACKARD NOR DAVID BETZ BE LIABLE FOR ANY SPECIAL, X* INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM X* LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE X* OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR X* PERFORMANCE OF THIS SOFTWARE. X* X* See ./winterp/COPYRIGHT for information on contacting the authors. X* X* Please send modifications, improvements and bugfixes to mayer@hplabs.hp.com X* Post XLISP-specific questions/information to the newsgroup comp.lang.lisp.x X* X******************************************************************************** X*/ Xstatic char rcs_identity[] = "@(#)$Header: xlfio.c,v 1.4 89/11/25 05:24:44 mayer Exp $"; X X#include "xlisp.h" X X/* external variables */ Xextern LVAL k_direction,k_input,k_output; Xextern LVAL s_stdin,s_stdout,s_stderr,true; Xextern unsigned char buf[]; Xextern int xlfsize; X X/* external routines */ Xextern FILE *osaopen(); X X/* forward declarations */ XFORWARD LVAL getstroutput(); XFORWARD LVAL printit(); XFORWARD LVAL flatsize(); XFORWARD LVAL openit(); X X/* xread - read an expression */ XLVAL xread() X{ X LVAL fptr,eof,rflag,val; X X /* get file pointer and eof value */ X fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin)); X eof = (moreargs() ? xlgetarg() : NIL); X rflag = (moreargs() ? xlgetarg() : NIL); X xllastarg(); X X /* read an expression */ X if (!xlread(fptr,&val,rflag != NIL)) X val = eof; X X /* return the expression */ X return (val); X} X X/* xprint - built-in function 'print' */ XLVAL xprint() X{ X return (printit(TRUE,TRUE)); X} X X/* xprin1 - built-in function 'prin1' */ XLVAL xprin1() X{ X return (printit(TRUE,FALSE)); X} X X/* xprinc - built-in function princ */ XLVAL xprinc() X{ X return (printit(FALSE,FALSE)); X} X X/* xterpri - terminate the current print line */ XLVAL xterpri() X{ X LVAL fptr; X X /* get file pointer */ X fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout)); X xllastarg(); X X /* terminate the print line and return nil */ X xlterpri(fptr); X return (NIL); X} X X/* printit - common print function */ XLOCAL LVAL printit(pflag,tflag) X int pflag,tflag; X{ X LVAL fptr,val; X X /* get expression to print and file pointer */ X val = xlgetarg(); X fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout)); X xllastarg(); X X /* print the value */ X xlprint(fptr,val,pflag); X X /* terminate the print line if necessary */ X if (tflag) X xlterpri(fptr); X X /* return the result */ X return (val); X} X X/* xflatsize - compute the size of a printed representation using prin1 */ XLVAL xflatsize() X{ X return (flatsize(TRUE)); X} X X/* xflatc - compute the size of a printed representation using princ */ XLVAL xflatc() X{ X return (flatsize(FALSE)); X} X X/* flatsize - compute the size of a printed expression */ XLOCAL LVAL flatsize(pflag) X int pflag; X{ X LVAL val; X X /* get the expression */ X val = xlgetarg(); X xllastarg(); X X /* print the value to compute its size */ X xlfsize = 0; X xlprint(NIL,val,pflag); X X /* return the length of the expression */ X return (cvfixnum((FIXTYPE)xlfsize)); X} X X/* xopen - open a file */ XLVAL xopen() X{ X char *name,*mode; X FILE *fp; X LVAL dir; X X /* get the file name and direction */ X name = (char *)getstring(xlgetfname()); X if (!xlgetkeyarg(k_direction,&dir)) X dir = k_input; X X /* get the mode */ X if (dir == k_input) X mode = "r"; X else if (dir == k_output) X mode = "w"; X else X xlerror("bad direction",dir); X X /* try to open the file */ X return ((fp = osaopen(name,mode)) ? cvfile(fp) : NIL); X} X X/* xclose - close a file */ XLVAL xclose() X{ X LVAL fptr; X X /* get file pointer */ X fptr = xlgastream(); X xllastarg(); X X /* make sure the file exists */ X if (getfile(fptr) == NULL) X xlfail("file not open"); X X /* close the file */ X osclose(getfile(fptr)); X setfile(fptr,NULL); X X /* return nil */ X return (NIL); X} X X/* xrdchar - read a character from a file */ XLVAL xrdchar() X{ X LVAL fptr; X int ch; X X /* get file pointer */ X fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin)); X xllastarg(); X X /* get character and check for eof */ X return ((ch = xlgetc(fptr)) == EOF ? NIL : cvchar(ch)); X} X X/* xrdbyte - read a byte from a file */ XLVAL xrdbyte() X{ X LVAL fptr; X int ch; X X /* get file pointer */ X fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin)); X xllastarg(); X X /* get character and check for eof */ X return ((ch = xlgetc(fptr)) == EOF ? NIL : cvfixnum((FIXTYPE)ch)); X} X X/* xpkchar - peek at a character from a file */ XLVAL xpkchar() X{ X LVAL flag,fptr; X int ch; X X /* peek flag and get file pointer */ X flag = (moreargs() ? xlgetarg() : NIL); X fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin)); X xllastarg(); X X /* skip leading white space and get a character */ X if (flag) X while ((ch = xlpeek(fptr)) != EOF && isspace(ch)) X xlgetc(fptr); X else X ch = xlpeek(fptr); X X /* return the character */ X return (ch == EOF ? NIL : cvchar(ch)); X} X X/* xwrchar - write a character to a file */ XLVAL xwrchar() X{ X LVAL fptr,chr; X X /* get the character and file pointer */ X chr = xlgachar(); X fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout)); X xllastarg(); X X /* put character to the file */ X xlputc(fptr,getchcode(chr)); X X /* return the character */ X return (chr); X} X X/* xwrbyte - write a byte to a file */ XLVAL xwrbyte() X{ X LVAL fptr,chr; X X /* get the byte and file pointer */ X chr = xlgafixnum(); X fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout)); X xllastarg(); X X /* put byte to the file */ X xlputc(fptr,(int)getfixnum(chr)); X X /* return the character */ X return (chr); X} X X/* xreadline - read a line from a file */ XLVAL xreadline() X{ X unsigned char buf[STRMAX+1],*p,*sptr; X LVAL fptr,str,newstr; X int len,blen,ch; X X /* protect some pointers */ X xlsave1(str); X X /* get file pointer */ X fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin)); X xllastarg(); X X /* get character and check for eof */ X len = blen = 0; p = buf; X while ((ch = xlgetc(fptr)) != EOF && ch != '\n') { X X /* check for buffer overflow */ X if (blen >= STRMAX) { X newstr = newstring(len + STRMAX + 1); X sptr = getstring(newstr); *sptr = '\0'; X if (str) strcat(sptr,getstring(str)); X *p = '\0'; strcat(sptr,buf); X p = buf; blen = 0; X len += STRMAX; X str = newstr; X } X X /* store the character */ X *p++ = ch; ++blen; X } X X /* check for end of file */ X if (len == 0 && p == buf && ch == EOF) { X xlpop(); X return (NIL); X } X X /* append the last substring */ X if (str == NIL || blen) { X newstr = newstring(len + blen + 1); X sptr = getstring(newstr); *sptr = '\0'; X if (str) strcat(sptr,getstring(str)); X *p = '\0'; strcat(sptr,buf); X str = newstr; X } X X /* restore the stack */ X xlpop(); X X /* return the string */ X return (str); X} X X X/* xmkstrinput - make a string input stream */ XLVAL xmkstrinput() X{ X int start,end,len,i; X unsigned char *str; X LVAL string,val; X X /* protect the return value */ X xlsave1(val); X X /* get the string and length */ X string = xlgastring(); X str = getstring(string); X len = getslength(string) - 1; X X /* get the starting offset */ X if (moreargs()) { X val = xlgafixnum(); X start = (int)getfixnum(val); X } X else start = 0; X X /* get the ending offset */ X if (moreargs()) { X val = xlgafixnum(); X end = (int)getfixnum(val); X } X else end = len; X xllastarg(); X X /* check the bounds */ X if (start < 0 || start > len) X xlerror("string index out of bounds",cvfixnum((FIXTYPE)start)); X if (end < 0 || end > len) X xlerror("string index out of bounds",cvfixnum((FIXTYPE)end)); X X /* make the stream */ X val = newustream(); X X /* copy the substring into the stream */ X for (i = start; i < end; ++i) X xlputc(val,str[i]); X X /* restore the stack */ X xlpop(); X X /* return the new stream */ X return (val); X} X X/* xmkstroutput - make a string output stream */ XLVAL xmkstroutput() X{ X return (newustream()); X} X X/* xgetstroutput - get output stream string */ XLVAL xgetstroutput() X{ X LVAL stream; X stream = xlgaustream(); X xllastarg(); X return (getstroutput(stream)); X} X X/* xgetlstoutput - get output stream list */ XLVAL xgetlstoutput() X{ X LVAL stream,val; X X /* get the stream */ X stream = xlgaustream(); X xllastarg(); X X /* get the output character list */ X val = gethead(stream); X X /* empty the character list */ X sethead(stream,NIL); X settail(stream,NIL); X X /* return the list */ X return (val); X} X X/* xformat - formatted output function */ XLVAL xformat() X{ X LVAL fmtstring,stream,val; X unsigned char *fmt; X int ch; X X /* protect some pointers */ X xlstkcheck(2); X xlsave(fmtstring); X xlsave(stream); X X /* get the stream and format string */ X stream = xlgetarg(); X if (stream == NIL) X val = stream = newustream(); X else { X if (stream == true) X stream = getvalue(s_stdout); X else if (!streamp(stream) && !ustreamp(stream)) X xlbadtype(stream); X val = NIL; X } X fmtstring = xlgastring(); X fmt = getstring(fmtstring); X X /* process the format string */ X while (ch = *fmt++) X if (ch == '~') { X switch (*fmt++) { X case '\0': X xlerror("expecting a format directive",cvstring(fmt-1)); X case 'a': case 'A': X xlprint(stream,xlgetarg(),FALSE); X break; X case 's': case 'S': X xlprint(stream,xlgetarg(),TRUE); X break; X case '%': X xlterpri(stream); X break; X case '~': X xlputc(stream,'~'); X break; X case '\n': X while (*fmt && *fmt != '\n' && isspace(*fmt)) X ++fmt; X break; X default: X xlerror("unknown format directive",cvstring(fmt-1)); X } X } X else X xlputc(stream,ch); X X /* get the output string for a stream argument of NIL */ X if (val) val = getstroutput(val); X xlpopn(2); X X /* return the value */ X return (val); X} X X/* getstroutput - get the output stream string (internal) */ XLOCAL LVAL getstroutput(stream) X LVAL stream; X{ X unsigned char *str; X LVAL next,val; X int len,ch; X X /* compute the length of the stream */ X for (len = 0, next = gethead(stream); next != NIL; next = cdr(next)) X ++len; X X /* create a new string */ X val = newstring(len + 1); X X /* copy the characters into the new string */ X str = getstring(val); X while ((ch = xlgetc(stream)) != EOF) X *str++ = ch; X *str = '\0'; X X /* return the string */ X return (val); X} X END_OF_FILE if test 11944 -ne `wc -c <'src/xlisp/xcore/c/xlfio.c'`; then echo shar: \"'src/xlisp/xcore/c/xlfio.c'\" unpacked with wrong size! fi # end of 'src/xlisp/xcore/c/xlfio.c' fi if test -f 'src/xlisp/xcore/c/xlisp.h' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'src/xlisp/xcore/c/xlisp.h'\" else echo shar: Extracting \"'src/xlisp/xcore/c/xlisp.h'\" $13662 characters$ sed "s/^X//" >'src/xlisp/xcore/c/xlisp.h' <<'END_OF_FILE' X/* X* -*-C-*- X******************************************************************************** X* X* File: xlisp.h X* RCS: $Header: xlisp.h,v 1.6 89/12/17 19:05:05 mayer Exp $ X* Description: libXlisp.a external interfaces X* Author: David Michael Betz; Niels Mayer X* Created: X* Modified: Sun Dec 17 04:50:59 1989 (Niels Mayer) mayer@hplnpm X* Language: C X* Package: N/A X* Status: X11r4 contrib tape release X* X* WINTERP 1.0 Copyright 1989 Hewlett-Packard Company (by Niels Mayer). X* XLISP version 2.1, Copyright (c) 1989, by David Betz. X* X* Permission to use, copy, modify, distribute, and sell this software and its X* documentation for any purpose is hereby granted without fee, provided that X* the above copyright notice appear in all copies and that both that X* copyright notice and this permission notice appear in supporting X* documentation, and that the name of Hewlett-Packard and David Betz not be X* used in advertising or publicity pertaining to distribution of the software X* without specific, written prior permission. Hewlett-Packard and David Betz X* make no representations about the suitability of this software for any X* purpose. It is provided "as is" without express or implied warranty. X* X* HEWLETT-PACKARD AND DAVID BETZ DISCLAIM ALL WARRANTIES WITH REGARD TO THIS X* SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, X* IN NO EVENT SHALL HEWLETT-PACKARD NOR DAVID BETZ BE LIABLE FOR ANY SPECIAL, X* INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM X* LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE X* OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR X* PERFORMANCE OF THIS SOFTWARE. X* X* See ./winterp/COPYRIGHT for information on contacting the authors. X* X* Please send modifications, improvements and bugfixes to mayer@hplabs.hp.com X* Post XLISP-specific questions/information to the newsgroup comp.lang.lisp.x X* X******************************************************************************** X*/ X X#ifndef __XLISP_H__ X#define __XLISP_H__ X X#include <stdio.h> X#include <ctype.h> X#include <setjmp.h> X X/* NNODES number of nodes to allocate in each request (1000) */ X/* EDEPTH evaluation stack depth (2000) */ X/* ADEPTH argument stack depth (1000) */ X/* FORWARD type of a forward declaration () */ X/* LOCAL type of a local function (static) */ X/* AFMT printf format for addresses ("%x") */ X/* FIXTYPE data type for fixed point numbers (long) */ X/* ITYPE fixed point input conversion routine type (long atol()) */ X/* ICNV fixed point input conversion routine (atol) */ X/* IFMT printf format for fixed point numbers ("%ld") */ X/* FLOTYPE data type for floating point numbers (float) */ X/* OFFTYPE number the size of an address (int) */ X X X/* for BSD & SYSV Unix. */ X#ifdef UNIX X#define NNODES 2000 X#define AFMT "%lx" /* added by NPM */ X#define OFFTYPE long /* added by NPM */ X#define SAVERESTORE X#endif X X/* for Mips C compiler - Silicon Graphhics */ X#ifdef _BSD_COMPAT X#define LOCAL X#endif X X/* for the Turbo C compiler - MS-DOS, large model */ X#ifdef _TURBOC_ X#define NNODES 2000 X#define AFMT "%lx" X#define OFFTYPE long X#define SAVERESTORE X#endif X X/* for the AZTEC C compiler - MS-DOS, large model */ X#ifdef AZTEC_LM X#define NNODES 2000 X#define AFMT "%lx" X#define OFFTYPE long X#define CVPTR(x) ptrtoabs(x) X#define NIL (void *)0 Xextern long ptrtoabs(); X#define SAVERESTORE X#endif X X/* for the AZTEC C compiler - Macintosh */ X#ifdef AZTEC_MAC X#define NNODES 2000 X#define AFMT "%lx" X#define OFFTYPE long X#define NIL (void *)0 X#define SAVERESTORE X#endif X X/* for the AZTEC C compiler - Amiga */ X#ifdef AZTEC_AMIGA X#define NNODES 2000 X#define AFMT "%lx" X#define OFFTYPE long X#define NIL (void *)0 X#define SAVERESTORE X#endif X X/* for the Lightspeed C compiler - Macintosh */ X#ifdef LSC X#define NNODES 2000 X#define AFMT "%lx" X#define OFFTYPE long X#define NIL (void *)0 X#define SAVERESTORE X#endif X X/* for the Microsoft C compiler - MS-DOS, large model */ X#ifdef MSC X#define NNODES 2000 X#define AFMT "%lx" X#define OFFTYPE long X#endif X X/* for the Mark Williams C compiler - Atari ST */ X#ifdef MWC X#define AFMT "%lx" X#define OFFTYPE long X#endif X X/* for the Lattice C compiler - Atari ST */ X#ifdef LATTICE X#define FIXTYPE int X#define ITYPE int atoi() X#define ICNV(n) atoi(n) X#define IFMT "%d" X#endif X X/* for the Digital Research C compiler - Atari ST */ X#ifdef DR X#define LOCAL X#define AFMT "%lx" X#define OFFTYPE long X#undef NULL X#define NULL 0L X#endif X X X/* default important definitions */ X#ifndef NNODES X#define NNODES 1000 X#endif X#ifndef EDEPTH X#define EDEPTH 2000 X#endif X#ifndef ADEPTH X#define ADEPTH 1000 X#endif X#ifndef FORWARD X#define FORWARD X#endif X#ifndef LOCAL X#define LOCAL static X#endif X#ifndef AFMT X#define AFMT "%x" X#endif X#ifndef FIXTYPE X#define FIXTYPE long X#endif X#ifndef ITYPE X#define ITYPE long atol() X#endif X#ifndef ICNV X#define ICNV(n) atol(n) X#endif X#ifndef IFMT X#define IFMT "%ld" X#endif X#ifndef FLOTYPE X#define FLOTYPE double X#endif X#ifndef OFFTYPE X#define OFFTYPE int X#endif X#ifndef CVPTR X#define CVPTR(x) (x) X#endif X#ifndef UCHAR X#define UCHAR unsigned char X#endif X X/* useful definitions */ X#ifndef TRUE X#define TRUE (1) X#endif X#ifndef FALSE X#define FALSE (0) X#endif X#ifndef NIL X#define NIL (LVAL )0 X#endif X X/* instance variable numbers for the class 'Class' */ X#define MESSAGES 0 /* list of messages */ X#define IVARS 1 /* list of instance variable names */ X#define CVARS 2 /* list of class variable names */ X#define CVALS 3 /* vector of class variable values */ X#define SUPERCLASS 4 /* pointer to the superclass */ X#define IVARCNT 5 /* number of class instance variables */ X#define IVARTOTAL 6 /* total number of instance variables */ X/* number of instance variables for the class 'Class' */ X#define CLASSSIZE 7 X X/* Include PROVIDE_XXX #defines for extension modules. *//* JSP */ X#define MODULE_XLISP_H_PROVIDES X#include "../../xmodules.h" X#undef MODULE_XLISP_H_PROVIDES X X/* include the dynamic memory definitions */ X#include "xldmem.h" X X/* program limits */ X#define STRMAX 100 /* maximum length of a string constant */ X#define HSIZE 199 /* symbol hash table size */ X#define SAMPLE 100 /* control character sample rate */ X X/* function table offsets for the initialization functions */ X#define FT_RMHASH 0 X#define FT_RMQUOTE 1 X#define FT_RMDQUOTE 2 X#define FT_RMBQUOTE 3 X#define FT_RMCOMMA 4 X#define FT_RMLPAR 5 X#define FT_RMRPAR 6 X#define FT_RMSEMI 7 X/* #define xxxxxx 8 */ X/* #define yyyyyy 9 */ X X#define FT_CLNEW 10 X#define FT_CLISNEW 11 X#define FT_CLANSWER 12 X#define FT_OBISNEW 13 X#define FT_OBCLASS 14 X#define FT_OBSHOW 15 X X#define LAST_FUNTAB_POINTER_USED_BY_libXlisp FT_OBSHOW X X/* include hybrid function in xlisp symbol table */ /* Voodoo */ X/* use from within user implemented xlinclude_hybrid_prims */ X/* or from within user implemented .h which xmodules.h includes */ X#define DEFINE_SUBR(a,b) xldefine_prim(a, SUBR, b); X#define DEFINE_FSUBR(a,b) xldefine_prim(a, FSUBR, b); X X/* macro to push a value onto the argument stack */ X#define pusharg(x) {if (xlsp >= xlargstktop) xlargstkoverflow();\ X *xlsp++ = (x);} X X/* macros to protect pointers */ X#define xlstkcheck(n) {if (xlstack - (n) < xlstkbase) xlstkoverflow();} X#define xlsave(n) {*--xlstack = &n; n = NIL;} X#define xlprotect(n) {*--xlstack = &n;} X X/* check the stack and protect a single pointer */ X#define xlsave1(n) {if (xlstack <= xlstkbase) xlstkoverflow();\ X *--xlstack = &n; n = NIL;} X#define xlprot1(n) {if (xlstack <= xlstkbase) xlstkoverflow();\ X *--xlstack = &n;} X X/* macros to pop pointers off the stack */ X#define xlpop() {++xlstack;} X#define xlpopn(n) {xlstack+=(n);} X X/* macros to manipulate the lexical environment */ X#define xlframe(e) cons(NIL,e) X#define xlbind(s,v) xlpbind(s,v,xlenv) X#define xlfbind(s,v) xlpbind(s,v,xlfenv); X#define xlpbind(s,v,e) {rplaca(e,cons(cons(s,v),car(e)));} X X/* macros to manipulate the dynamic environment */ X#define xldbind(s,v) {xldenv = cons(cons(s,getvalue(s)),xldenv);\ X setvalue(s,v);} X#define xlunbind(e) {for (; xldenv != (e); xldenv = cdr(xldenv))\ X setvalue(car(car(xldenv)),cdr(car(xldenv)));} X X/* type predicates */ X#define atom(x) ((x) == NIL || ntype(x) != CONS) X#define null(x) ((x) == NIL) X#define listp(x) ((x) == NIL || ntype(x) == CONS) X#define consp(x) ((x) && ntype(x) == CONS) X#define subrp(x) ((x) && ntype(x) == SUBR) X#define fsubrp(x) ((x) && ntype(x) == FSUBR) X#define stringp(x) ((x) && ntype(x) == STRING) X#define symbolp(x) ((x) && ntype(x) == SYMBOL) X#define streamp(x) ((x) && ntype(x) == STREAM) X X#define objectp(x) ((x) && ntype(x) == OBJECT) X X#define fixp(x) ((x) && ntype(x) == FIXNUM) X#define floatp(x) ((x) && ntype(x) == FLONUM) X#define vectorp(x) ((x) && ntype(x) == VECTOR) X#define closurep(x) ((x) && ntype(x) == CLOSURE) X#define charp(x) ((x) && ntype(x) == CHAR) X#define ustreamp(x) ((x) && ntype(x) == USTREAM) X#define structp(x) ((x) && ntype(x) == STRUCT) X#define boundp(x) (getvalue(x) != s_unbound) X#define fboundp(x) (getfunction(x) != s_unbound) X X/* shorthand functions */ X#define consa(x) cons(x,NIL) X#define consd(x) cons(NIL,x) X X/* set element of a vector */ /* Voodoo */ X#define stuff_fixnum(arg, ind, val) ((arg)->n_vdata[ind])->n_fixnum = (val) X#define stuff_flonum(arg, ind, val) ((arg)->n_vdata[ind])->n_flonum = (val) X X/* argument list parsing macros */ X#define xlgetarg() (testarg(nextarg())) X#define xllastarg() {if (xlargc != 0) xltoomany();} X#define testarg(e) (moreargs() ? (e) : xltoofew()) X#define typearg(tp) (tp(*xlargv) ? nextarg() : xlbadtype(*xlargv)) X#define nextarg() (--xlargc, *xlargv++) X#define moreargs() (xlargc > 0) X X/* macros to get arguments of a particular type */ X#define xlgacons() (testarg(typearg(consp))) X#define xlgalist() (testarg(typearg(listp))) X#define xlgasymbol() (testarg(typearg(symbolp))) X#define xlgastring() (testarg(typearg(stringp))) X#define xlgaobject() (testarg(typearg(objectp))) X#define xlgafixnum() (testarg(typearg(fixp))) X#define xlgaflonum() (testarg(typearg(floatp))) X#define xlgachar() (testarg(typearg(charp))) X#define xlgavector() (testarg(typearg(vectorp))) X#define xlgastream() (testarg(typearg(streamp))) X#define xlgaustream() (testarg(typearg(ustreamp))) X#define xlgaclosure() (testarg(typearg(closurep))) X#define xlgastruct() (testarg(typearg(structp))) X X#ifndef OPTIMAL /* Voodoo */ X#define xlsetjmp(context) setjmp(context) X#define xllongjmp(context, mask) longjmp(context, mask) X#else X#define xlsetjmp(context) 0 X#define xllongjmp(context, mask) \ X{ \ X xlfatal("can't recover, bye..."); \ X exit(0); \ X } X#endif X X/* function definition structure */ Xtypedef struct { X char *fd_name; /* function name */ X int fd_type; /* function type */ X LVAL (*fd_subr)(); /* function entry point */ X} FUNDEF; X X/* execution context flags */ X#define CF_GO 0x0001 X#define CF_RETURN 0x0002 X#define CF_THROW 0x0004 X#define CF_ERROR 0x0008 X#define CF_CLEANUP 0x0010 X#define CF_CONTINUE 0x0020 X#define CF_TOPLEVEL 0x0040 X#define CF_BRKLEVEL 0x0080 X#define CF_UNWIND 0x0100 X X/* execution context */ Xtypedef struct context { X int c_flags; /* context type flags */ X LVAL c_expr; /* expression (type dependant) */ X jmp_buf c_jmpbuf; /* longjmp context */ X struct context *c_xlcontext; /* old value of xlcontext */ X LVAL **c_xlstack; /* old value of xlstack */ X LVAL *c_xlargv; /* old value of xlargv */ X int c_xlargc; /* old value of xlargc */ X LVAL *c_xlfp; /* old value of xlfp */ X LVAL *c_xlsp; /* old value of xlsp */ X LVAL c_xlenv; /* old value of xlenv */ X LVAL c_xlfenv; /* old value of xlfenv */ X LVAL c_xldenv; /* old value of xldenv */ X} CONTEXT; X X/* external variables */ Xextern LVAL **xlstktop; /* top of the evaluation stack */ Xextern LVAL **xlstkbase; /* base of the evaluation stack */ Xextern LVAL **xlstack; /* evaluation stack pointer */ Xextern LVAL *xlargstkbase; /* base of the argument stack */ Xextern LVAL *xlargstktop; /* top of the argument stack */ Xextern LVAL *xlfp; /* argument frame pointer */ Xextern LVAL *xlsp; /* argument stack pointer */ Xextern LVAL *xlargv; /* current argument vector */ Xextern int xlargc; /* current argument count */ X X/* external procedure declarations */ Xextern LVAL xleval(); /* evaluate an expression */ Xextern LVAL xlapply(); /* apply a function to arguments */ Xextern LVAL xlsubr(); /* enter a subr/fsubr */ Xextern LVAL xlenter(); /* enter a symbol */ Xextern LVAL xlmakesym(); /* make an uninterned symbol */ Xextern LVAL xlgetvalue(); /* get value of a symbol (checked) */ Xextern LVAL xlxgetvalue(); /* get value of a symbol */ Xextern LVAL xlgetfunction(); /* get functional value of a symbol */ Xextern LVAL xlxgetfunction(); /* get functional value of a symbol (checked) */ Xextern LVAL xlexpandmacros(); /* expand macros in a form */ Xextern LVAL xlgetprop(); /* get the value of a property */ Xextern LVAL xlclose(); /* create a function closure */ X Xextern void xldefine_prim(); /* load xlisp function */ /* Voodoo */ X X/* argument list parsing functions */ Xextern LVAL xlgetfile(); /* get a file/stream argument */ Xextern LVAL xlgetfname(); /* get a filename argument */ X X/* error reporting functions (don't *really* return at all) */ Xextern LVAL xltoofew(); /* report "too few arguments" error */ Xextern LVAL xlbadtype(); /* report "bad argument type" error */ X X X/* Include hybrid-class functions. *//* JSP */ X/* (Last so you can #undef stuff.) *//* JSP */ X#define MODULE_XLISP_H_GLOBALS X#include "../../xmodules.h" X#undef MODULE_XLISP_H_GLOBALS X X#endif /* __XLISP_H__ */ END_OF_FILE if test 13662 -ne `wc -c <'src/xlisp/xcore/c/xlisp.h'`; then echo shar: \"'src/xlisp/xcore/c/xlisp.h'\" unpacked with wrong size! fi # end of 'src/xlisp/xcore/c/xlisp.h' fi if test -f 'src/xlisp/xcore/c/xlmath.c' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'src/xlisp/xcore/c/xlmath.c'\" else echo shar: Extracting \"'src/xlisp/xcore/c/xlmath.c'\" $11975 characters$ sed "s/^X//" >'src/xlisp/xcore/c/xlmath.c' <<'END_OF_FILE' X/* -*-C-*- X******************************************************************************** X* X* File: xlmath.c X* RCS: $Header: xlmath.c,v 1.3 89/11/25 05:40:35 mayer Exp $ X* Description: xlisp built-in arithmetic functions X* Author: David Michael Betz X* Created: X* Modified: Sat Nov 25 05:40:27 1989 (Niels Mayer) mayer@hplnpm X* Language: C X* Package: N/A X* Status: X11r4 contrib tape release X* X* WINTERP 1.0 Copyright 1989 Hewlett-Packard Company (by Niels Mayer). X* XLISP version 2.1, Copyright (c) 1989, by David Betz. X* X* Permission to use, copy, modify, distribute, and sell this software and its X* documentation for any purpose is hereby granted without fee, provided that X* the above copyright notice appear in all copies and that both that X* copyright notice and this permission notice appear in supporting X* documentation, and that the name of Hewlett-Packard and David Betz not be X* used in advertising or publicity pertaining to distribution of the software X* without specific, written prior permission. Hewlett-Packard and David Betz X* make no representations about the suitability of this software for any X* purpose. It is provided "as is" without express or implied warranty. X* X* HEWLETT-PACKARD AND DAVID BETZ DISCLAIM ALL WARRANTIES WITH REGARD TO THIS X* SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, X* IN NO EVENT SHALL HEWLETT-PACKARD NOR DAVID BETZ BE LIABLE FOR ANY SPECIAL, X* INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM X* LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE X* OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR X* PERFORMANCE OF THIS SOFTWARE. X* X* See ./winterp/COPYRIGHT for information on contacting the authors. X* X* Please send modifications, improvements and bugfixes to mayer@hplabs.hp.com X* Post XLISP-specific questions/information to the newsgroup comp.lang.lisp.x X* X******************************************************************************** X*/ Xstatic char rcs_identity[] = "@(#)$Header: xlmath.c,v 1.3 89/11/25 05:40:35 mayer Exp $"; X X X#include "xlisp.h" X#include <math.h> X X/* external variables */ Xextern LVAL true; X X/* forward declarations */ XFORWARD LVAL unary(); XFORWARD LVAL binary(); XFORWARD LVAL predicate(); XFORWARD LVAL compare(); X X/* binary functions */ XLVAL xadd() { return (binary('+')); } /* + */ XLVAL xsub() { return (binary('-')); } /* - */ XLVAL xmul() { return (binary('*')); } /* * */ XLVAL xdiv() { return (binary('/')); } /* / */ XLVAL xrem() { return (binary('%')); } /* rem */ XLVAL xmin() { return (binary('m')); } /* min */ XLVAL xmax() { return (binary('M')); } /* max */ XLVAL xexpt() { return (binary('E')); } /* expt */ XLVAL xlogand() { return (binary('&')); } /* logand */ XLVAL xlogior() { return (binary('|')); } /* logior */ XLVAL xlogxor() { return (binary('^')); } /* logxor */ X X/* xgcd - greatest common divisor */ XLVAL xgcd() X{ X FIXTYPE m,n,r; X LVAL arg; X X if (!moreargs()) /* check for identity case */ X return (cvfixnum((FIXTYPE)0)); X arg = xlgafixnum(); X n = getfixnum(arg); X if (n < (FIXTYPE)0) n = -n; /* absolute value */ X while (moreargs()) { X arg = xlgafixnum(); X m = getfixnum(arg); X if (m < (FIXTYPE)0) m = -m; /* absolute value */ X for (;;) { /* euclid's algorithm */ X r = m % n; X if (r == (FIXTYPE)0) X break; X m = n; X n = r; X } X } X return (cvfixnum(n)); X} X X/* binary - handle binary operations */ XLOCAL LVAL binary(fcn) X int fcn; X{ X FIXTYPE ival,iarg; X FLOTYPE fval,farg; X LVAL arg; X int mode; X X /* get the first argument */ X arg = xlgetarg(); X X /* set the type of the first argument */ X if (fixp(arg)) { X ival = getfixnum(arg); X mode = 'I'; X } X else if (floatp(arg)) { X fval = getflonum(arg); X mode = 'F'; X } X else X xlerror("bad argument type",arg); X X /* treat a single argument as a special case */ X if (!moreargs()) { X switch (fcn) { X case '-': X switch (mode) { X case 'I': X ival = -ival; X break; X case 'F': X fval = -fval; X break; X } X break; X case '/': X switch (mode) { X case 'I': X checkizero(ival); X ival = 1 / ival; X break; X case 'F': X checkfzero(fval); X fval = 1.0 / fval; X break; X } X } X } X X /* handle each remaining argument */ X while (moreargs()) { X X /* get the next argument */ X arg = xlgetarg(); X X /* check its type */ X if (fixp(arg)) { X switch (mode) { X case 'I': X iarg = getfixnum(arg); X break; X case 'F': X farg = (FLOTYPE)getfixnum(arg); X break; X } X } X else if (floatp(arg)) { X switch (mode) { X case 'I': X fval = (FLOTYPE)ival; X farg = getflonum(arg); X mode = 'F'; X break; X case 'F': X farg = getflonum(arg); X break; X } X } X else X xlerror("bad argument type",arg); X X /* accumulate the result value */ X switch (mode) { X case 'I': X switch (fcn) { X case '+': ival += iarg; break; X case '-': ival -= iarg; break; X case '*': ival *= iarg; break; X case '/': checkizero(iarg); ival /= iarg; break; X case '%': checkizero(iarg); ival %= iarg; break; X case 'M': if (iarg > ival) ival = iarg; break; X case 'm': if (iarg < ival) ival = iarg; break; X case '&': ival &= iarg; break; X case '|': ival |= iarg; break; X case '^': ival ^= iarg; break; X default: badiop(); X } X break; X case 'F': X switch (fcn) { X case '+': fval += farg; break; X case '-': fval -= farg; break; X case '*': fval *= farg; break; X case '/': checkfzero(farg); fval /= farg; break; X case 'M': if (farg > fval) fval = farg; break; X case 'm': if (farg < fval) fval = farg; break; X case 'E': fval = pow(fval,farg); break; X default: badfop(); X } X break; X } X } X X /* return the result */ X switch (mode) { X case 'I': return (cvfixnum(ival)); X case 'F': return (cvflonum(fval)); X } X} X X/* checkizero - check for integer division by zero */ XLOCAL checkizero(iarg) X FIXTYPE iarg; X{ X if (iarg == 0) X xlfail("division by zero"); X} X X/* checkfzero - check for floating point division by zero */ XLOCAL checkfzero(farg) X FLOTYPE farg; X{ X if (farg == 0.0) X xlfail("division by zero"); X} X X/* checkfneg - check for square root of a negative number */ XLOCAL checkfneg(farg) X FLOTYPE farg; X{ X if (farg < 0.0) X xlfail("square root of a negative number"); X} X X/* unary functions */ XLVAL xlognot() { return (unary('~')); } /* lognot */ XLVAL xabs() { return (unary('A')); } /* abs */ XLVAL xadd1() { return (unary('+')); } /* 1+ */ XLVAL xsub1() { return (unary('-')); } /* 1- */ XLVAL xsin() { return (unary('S')); } /* sin */ XLVAL xcos() { return (unary('C')); } /* cos */ XLVAL xtan() { return (unary('T')); } /* tan */ XLVAL xasin() { return (unary('s')); } /* asin */ XLVAL xacos() { return (unary('c')); } /* acos */ XLVAL xatan() { return (unary('t')); } /* atan */ XLVAL xexp() { return (unary('E')); } /* exp */ XLVAL xsqrt() { return (unary('R')); } /* sqrt */ XLVAL xfix() { return (unary('I')); } /* truncate */ XLVAL xfloat() { return (unary('F')); } /* float */ XLVAL xrand() { return (unary('?')); } /* random */ X X/* unary - handle unary operations */ XLOCAL LVAL unary(fcn) X int fcn; X{ X FLOTYPE fval; X FIXTYPE ival; X LVAL arg; X X /* get the argument */ X arg = xlgetarg(); X xllastarg(); X X /* check its type */ X if (fixp(arg)) { X ival = getfixnum(arg); X switch (fcn) { X case '~': ival = ~ival; break; X case 'A': ival = (ival < 0 ? -ival : ival); break; X case '+': ival++; break; X case '-': ival--; break; X case 'I': break; X case 'F': return (cvflonum((FLOTYPE)ival)); X case '?': ival = (FIXTYPE)osrand((int)ival); break; X default: badiop(); X } X return (cvfixnum(ival)); X } X else if (floatp(arg)) { X fval = getflonum(arg); X switch (fcn) { X case 'A': fval = (fval < 0.0 ? -fval : fval); break; X case '+': fval += 1.0; break; X case '-': fval -= 1.0; break; X case 'S': fval = sin(fval); break; X case 'C': fval = cos(fval); break; X case 'T': fval = tan(fval); break; X case 's': fval = asin(fval); break; X case 'c': fval = acos(fval); break; X case 't': fval = atan(fval); break; X case 'E': fval = exp(fval); break; X case 'R': checkfneg(fval); fval = sqrt(fval); break; X case 'I': return (cvfixnum((FIXTYPE)fval)); X case 'F': break; X default: badfop(); X } X return (cvflonum(fval)); X } X else X xlerror("bad argument type",arg); X} X X/* unary predicates */ XLVAL xminusp() { return (predicate('-')); } /* minusp */ XLVAL xzerop() { return (predicate('Z')); } /* zerop */ XLVAL xplusp() { return (predicate('+')); } /* plusp */ XLVAL xevenp() { return (predicate('E')); } /* evenp */ XLVAL xoddp() { return (predicate('O')); } /* oddp */ X X/* predicate - handle a predicate function */ XLOCAL LVAL predicate(fcn) X int fcn; X{ X FLOTYPE fval; X FIXTYPE ival; X LVAL arg; X X /* get the argument */ X arg = xlgetarg(); X xllastarg(); X X /* check the argument type */ X if (fixp(arg)) { X ival = getfixnum(arg); X switch (fcn) { X case '-': ival = (ival < 0); break; X case 'Z': ival = (ival == 0); break; X case '+': ival = (ival > 0); break; X case 'E': ival = ((ival & 1) == 0); break; X case 'O': ival = ((ival & 1) != 0); break; X default: badiop(); X } X } X else if (floatp(arg)) { X fval = getflonum(arg); X switch (fcn) { X case '-': ival = (fval < 0); break; X case 'Z': ival = (fval == 0); break; X case '+': ival = (fval > 0); break; X default: badfop(); X } X } X else X xlerror("bad argument type",arg); X X /* return the result value */ X return (ival ? true : NIL); X} X X/* comparison functions */ XLVAL xlss() { return (compare('<')); } /* < */ XLVAL xleq() { return (compare('L')); } /* <= */ XLVAL xequ() { return (compare('=')); } /* = */ XLVAL xneq() { return (compare('#')); } /* /= */ XLVAL xgeq() { return (compare('G')); } /* >= */ XLVAL xgtr() { return (compare('>')); } /* > */ X X/* compare - common compare function */ XLOCAL LVAL compare(fcn) X int fcn; X{ X FIXTYPE icmp,ival,iarg; X FLOTYPE fcmp,fval,farg; X LVAL arg; X int mode; X X /* get the first argument */ X arg = xlgetarg(); X X /* set the type of the first argument */ X if (fixp(arg)) { X ival = getfixnum(arg); X mode = 'I'; X } X else if (floatp(arg)) { X fval = getflonum(arg); X mode = 'F'; X } X else X xlerror("bad argument type",arg); X X /* handle each remaining argument */ X for (icmp = TRUE; icmp && moreargs(); ival = iarg, fval = farg) { X X /* get the next argument */ X arg = xlgetarg(); X X /* check its type */ X if (fixp(arg)) { X switch (mode) { X case 'I': X iarg = getfixnum(arg); X break; X case 'F': X farg = (FLOTYPE)getfixnum(arg); X break; X } X } X else if (floatp(arg)) { X switch (mode) { X case 'I': X fval = (FLOTYPE)ival; X farg = getflonum(arg); X mode = 'F'; X break; X case 'F': X farg = getflonum(arg); X break; X } X } X else X xlerror("bad argument type",arg); X X /* compute result of the compare */ X switch (mode) { X case 'I': X icmp = ival - iarg; X switch (fcn) { X case '<': icmp = (icmp < 0); break; X case 'L': icmp = (icmp <= 0); break; X case '=': icmp = (icmp == 0); break; X case '#': icmp = (icmp != 0); break; X case 'G': icmp = (icmp >= 0); break; X case '>': icmp = (icmp > 0); break; X } X break; X case 'F': X fcmp = fval - farg; X switch (fcn) { X case '<': icmp = (fcmp < 0.0); break; X case 'L': icmp = (fcmp <= 0.0); break; X case '=': icmp = (fcmp == 0.0); break; X case '#': icmp = (fcmp != 0.0); break; X case 'G': icmp = (fcmp >= 0.0); break; X case '>': icmp = (fcmp > 0.0); break; X } X break; X } X } X X /* return the result */ X return (icmp ? true : NIL); X} X X/* badiop - bad integer operation */ XLOCAL badiop() X{ X xlfail("bad integer operation"); X} X X/* badfop - bad floating point operation */ XLOCAL badfop() X{ X xlfail("bad floating point operation"); X} END_OF_FILE if test 11975 -ne `wc -c <'src/xlisp/xcore/c/xlmath.c'`; then echo shar: \"'src/xlisp/xcore/c/xlmath.c'\" unpacked with wrong size! fi # end of 'src/xlisp/xcore/c/xlmath.c' fi if test -f 'src/xlisp/xcore/c/xlstruct.c' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'src/xlisp/xcore/c/xlstruct.c'\" else echo shar: Extracting \"'src/xlisp/xcore/c/xlstruct.c'\" $12885 characters$ sed "s/^X//" >'src/xlisp/xcore/c/xlstruct.c' <<'END_OF_FILE' X/* -*-C-*- X******************************************************************************** X* X* File: xlstruct.c X* RCS: $Header: xlstruct.c,v 1.2 89/11/25 05:47:24 mayer Exp $ X* Description: the defstruct facility X* Author: David Michael Betz X* Created: X* Modified: Sat Nov 25 05:47:17 1989 (Niels Mayer) mayer@hplnpm X* Language: C X* Package: N/A X* Status: X11r4 contrib tape release X* X* WINTERP 1.0 Copyright 1989 Hewlett-Packard Company (by Niels Mayer). X* XLISP version 2.1, Copyright (c) 1989, by David Betz. X* X* Permission to use, copy, modify, distribute, and sell this software and its X* documentation for any purpose is hereby granted without fee, provided that X* the above copyright notice appear in all copies and that both that X* copyright notice and this permission notice appear in supporting X* documentation, and that the name of Hewlett-Packard and David Betz not be X* used in advertising or publicity pertaining to distribution of the software X* without specific, written prior permission. Hewlett-Packard and David Betz X* make no representations about the suitability of this software for any X* purpose. It is provided "as is" without express or implied warranty. X* X* HEWLETT-PACKARD AND DAVID BETZ DISCLAIM ALL WARRANTIES WITH REGARD TO THIS X* SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, X* IN NO EVENT SHALL HEWLETT-PACKARD NOR DAVID BETZ BE LIABLE FOR ANY SPECIAL, X* INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM X* LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE X* OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR X* PERFORMANCE OF THIS SOFTWARE. X* X* See ./winterp/COPYRIGHT for information on contacting the authors. X* X* Please send modifications, improvements and bugfixes to mayer@hplabs.hp.com X* Post XLISP-specific questions/information to the newsgroup comp.lang.lisp.x X* X******************************************************************************** X*/ Xstatic char rcs_identity[] = "@(#)$Header: xlstruct.c,v 1.2 89/11/25 05:47:24 mayer Exp $"; X X X#include "xlisp.h" X X/* external variables */ Xextern LVAL xlenv,xlfenv; Xextern LVAL s_lambda,s_quote,lk_key,true; Xextern char buf[]; X X/* local variables */ Xstatic prefix[STRMAX+1]; X X/* xmkstruct - the '%make-struct' function */ XLVAL xmkstruct() X{ X LVAL type,val; X int i; X X /* get the structure type */ X type = xlgasymbol(); X X /* make the structure */ X val = newstruct(type,xlargc); X X /* store each argument */ X for (i = 1; moreargs(); ++i) X setelement(val,i,nextarg()); X xllastarg(); X X /* return the structure */ X return (val); X} X X/* xcpystruct - the '%copy-struct' function */ XLVAL xcpystruct() X{ X LVAL str,val; X int size,i; X str = xlgastruct(); X xllastarg(); X size = getsz(str); X val = newstruct(getelement(str,0),size-1); X for (i = 1; i < size; ++i) X setelement(val,i,getelement(str,i)); X return (val); X} X X/* xstrref - the '%struct-ref' function */ XLVAL xstrref() X{ X LVAL str,val; X int i; X str = xlgastruct(); X val = xlgafixnum(); i = (int)getfixnum(val); X xllastarg(); X return (getelement(str,i)); X} X X/* xstrset - the '%struct-set' function */ XLVAL xstrset() X{ X LVAL str,val; X int i; X str = xlgastruct(); X val = xlgafixnum(); i = (int)getfixnum(val); X val = xlgetarg(); X xllastarg(); X setelement(str,i,val); X return (val); X} X X/* xstrtypep - the '%struct-type-p' function */ XLVAL xstrtypep() X{ X LVAL type,val; X type = xlgasymbol(); X val = xlgetarg(); X xllastarg(); X return (structp(val) && getelement(val,0) == type ? true : NIL); X} X X/* xdefstruct - the 'defstruct' special form */ XLVAL xdefstruct() X{ X LVAL structname,slotname,defexpr,sym,tmp,args,body; X LVAL options,oargs,slots; X char *pname; X int slotn; X X /* protect some pointers */ X xlstkcheck(6); X xlsave(structname); X xlsave(slotname); X xlsave(defexpr); X xlsave(args); X xlsave(body); X xlsave(tmp); X X /* initialize */ X args = body = NIL; X slotn = 0; X X /* get the structure name */ X tmp = xlgetarg(); X if (symbolp(tmp)) { X structname = tmp; X strcpy(prefix,getstring(getpname(structname))); X strcat(prefix,"-"); X } X X /* get the structure name and options */ X else if (consp(tmp) && symbolp(car(tmp))) { X structname = car(tmp); X strcpy(prefix,getstring(getpname(structname))); X strcat(prefix,"-"); X X /* handle the list of options */ X for (options = cdr(tmp); consp(options); options = cdr(options)) { X X /* get the next argument */ X tmp = car(options); X X /* handle options that don't take arguments */ X if (symbolp(tmp)) { X pname = (char *) getstring(getpname(tmp)); X xlerror("unknown option",tmp); X } X X /* handle options that take arguments */ X else if (consp(tmp) && symbolp(car(tmp))) { X pname = (char *) getstring(getpname(car(tmp))); X oargs = cdr(tmp); X X /* check for the :CONC-NAME keyword */ X if (strcmp(pname,":CONC-NAME") == 0) { X X /* get the name of the structure to include */ X if (!consp(oargs) || !symbolp(car(oargs))) X xlerror("expecting a symbol",oargs); X X /* save the prefix */ X strcpy(prefix,getstring(getpname(car(oargs)))); X } X X /* check for the :INCLUDE keyword */ X else if (strcmp(pname,":INCLUDE") == 0) { X X /* get the name of the structure to include */ X if (!consp(oargs) || !symbolp(car(oargs))) X xlerror("expecting a structure name",oargs); X tmp = car(oargs); X oargs = cdr(oargs); X X /* add each slot from the included structure */ X slots = xlgetprop(tmp,xlenter("*STRUCT-SLOTS*")); X for (; consp(slots); slots = cdr(slots)) { X if (consp(car(slots)) && consp(cdr(car(slots)))) { X X /* get the next slot description */ X tmp = car(slots); X X /* create the slot access functions */ X addslot(car(tmp),car(cdr(tmp)),++slotn,&args,&body); X } X } X X /* handle slot initialization overrides */ X for (; consp(oargs); oargs = cdr(oargs)) { X tmp = car(oargs); X if (symbolp(tmp)) { X slotname = tmp; X defexpr = NIL; X } X else if (consp(tmp) && symbolp(car(tmp))) { X slotname = car(tmp); X defexpr = (consp(cdr(tmp)) ? car(cdr(tmp)) : NIL); X } X else X xlerror("bad slot description",tmp); X updateslot(args,slotname,defexpr); X } X } X else X xlerror("unknown option",tmp); X } X else X xlerror("bad option syntax",tmp); X } X } X X /* get each of the structure members */ X while (moreargs()) { X X /* get the slot name and default value expression */ X tmp = xlgetarg(); X if (symbolp(tmp)) { X slotname = tmp; X defexpr = NIL; X } X else if (consp(tmp) && symbolp(car(tmp))) { X slotname = car(tmp); X defexpr = (consp(cdr(tmp)) ? car(cdr(tmp)) : NIL); X } X else X xlerror("bad slot description",tmp); X X /* create a closure for non-trival default expressions */ X if (defexpr != NIL) { X tmp = newclosure(NIL,s_lambda,xlenv,xlfenv); X setbody(tmp,cons(defexpr,NIL)); X tmp = cons(tmp,NIL); X defexpr = tmp; X } X X /* create the slot access functions */ X addslot(slotname,defexpr,++slotn,&args,&body); X } X X /* store the slotnames and default expressions */ X xlputprop(structname,args,xlenter("*STRUCT-SLOTS*")); X X /* enter the MAKE-xxx symbol */ X sprintf(buf,"MAKE-%s",getstring(getpname(structname))); X sym = xlenter(buf); X X /* make the MAKE-xxx function */ X args = cons(lk_key,args); X tmp = cons(structname,NIL); X tmp = cons(s_quote,tmp); X body = cons(tmp,body); X body = cons(xlenter("%MAKE-STRUCT"),body); X body = cons(body,NIL); X setfunction(sym, X xlclose(sym,s_lambda,args,body,xlenv,xlfenv)); X X /* enter the xxx-P symbol */ X sprintf(buf,"%s-P",getstring(getpname(structname))); X sym = xlenter(buf); X X /* make the xxx-P function */ X args = cons(xlenter("X"),NIL); X body = cons(xlenter("X"),NIL); X tmp = cons(structname,NIL); X tmp = cons(s_quote,tmp); X body = cons(tmp,body); X body = cons(xlenter("%STRUCT-TYPE-P"),body); X body = cons(body,NIL); X setfunction(sym, X xlclose(sym,s_lambda,args,body,NIL,NIL)); X X /* enter the COPY-xxx symbol */ X sprintf(buf,"COPY-%s",getstring(getpname(structname))); X sym = xlenter(buf); X X /* make the COPY-xxx function */ X args = cons(xlenter("X"),NIL); X body = cons(xlenter("X"),NIL); X body = cons(xlenter("%COPY-STRUCT"),body); X body = cons(body,NIL); X setfunction(sym, X xlclose(sym,s_lambda,args,body,NIL,NIL)); X X /* restore the stack */ X xlpopn(6); X X /* return the structure name */ X return (structname); X} X X/* xlrdstruct - convert a list to a structure (used by the reader) */ XLVAL xlrdstruct(list) X LVAL list; X{ X LVAL structname,sym,slotname,expr,last,val; X X /* protect the new structure */ X xlsave1(expr); X X /* get the structure name */ X if (!consp(list) || !symbolp(car(list))) X xlerror("bad structure initialization list",list); X structname = car(list); X list = cdr(list); X X /* enter the MAKE-xxx symbol */ X sprintf(buf,"MAKE-%s",getstring(getpname(structname))); X X /* initialize the MAKE-xxx function call expression */ X expr = cons(xlenter(buf),NIL); X last = expr; X X /* turn the rest of the initialization list into keyword arguments */ X while (consp(list) && consp(cdr(list))) { X X /* get the slot keyword name */ X slotname = car(list); X if (!symbolp(slotname)) X xlerror("expecting a slot name",slotname); X sprintf(buf,":%s",getstring(getpname(slotname))); X X /* add the slot keyword */ X rplacd(last,cons(xlenter(buf),NIL)); X last = cdr(last); X list = cdr(list); X X /* add the value expression */ X rplacd(last,cons(car(list),NIL)); X last = cdr(last); X list = cdr(list); X } X X /* make sure all of the initializers were used */ X if (consp(list)) X xlerror("bad structure initialization list",list); X X /* invoke the creation function */ X val = xleval(expr); X X /* restore the stack */ X xlpop(); X X /* return the new structure */ X return (val); X} X X/* xlprstruct - print a structure (used by printer) */ Xxlprstruct(fptr,vptr,flag) X LVAL fptr,vptr; int flag; X{ X LVAL next; X int i,n; X xlputc(fptr,'#'); xlputc(fptr,'S'); xlputc(fptr,'('); X xlprint(fptr,getelement(vptr,0),flag); X next = xlgetprop(getelement(vptr,0),xlenter("*STRUCT-SLOTS*")); X for (i = 1, n = getsz(vptr) - 1; i <= n && consp(next); ++i) { X if (consp(car(next))) { /* should always succeed */ X xlputc(fptr,' '); X xlprint(fptr,car(car(next)),flag); X xlputc(fptr,' '); X xlprint(fptr,getelement(vptr,i),flag); X } X next = cdr(next); X } X xlputc(fptr,')'); X} X X/* addslot - make the slot access functions */ XLOCAL addslot(slotname,defexpr,slotn,pargs,pbody) X LVAL slotname,defexpr; int slotn; LVAL *pargs,*pbody; X{ X LVAL sym,args,body,tmp; X X /* protect some pointers */ X xlstkcheck(4); X xlsave(sym); X xlsave(args); X xlsave(body); X xlsave(tmp); X X /* construct the update function name */ X sprintf(buf,"%s%s",prefix,getstring(getpname(slotname))); X sym = xlenter(buf); X X /* make the access function */ X args = cons(xlenter("S"),NIL); X body = cons(cvfixnum((FIXTYPE)slotn),NIL); X body = cons(xlenter("S"),body); X body = cons(xlenter("%STRUCT-REF"),body); X body = cons(body,NIL); X setfunction(sym, X xlclose(sym,s_lambda,args,body,NIL,NIL)); X X /* make the update function */ X args = cons(xlenter("V"),NIL); X args = cons(xlenter("S"),args); X body = cons(xlenter("V"),NIL); X body = cons(cvfixnum((FIXTYPE)slotn),body); X body = cons(xlenter("S"),body); X body = cons(xlenter("%STRUCT-SET"),body); X body = cons(body,NIL); X xlputprop(sym, X xlclose(NIL,s_lambda,args,body,NIL,NIL), X xlenter("*SETF*")); X X /* add the slotname to the make-xxx keyword list */ X tmp = cons(defexpr,NIL); X tmp = cons(slotname,tmp); X tmp = cons(tmp,NIL); X if ((args = *pargs) == NIL) X *pargs = tmp; X else { X while (cdr(args) != NIL) X args = cdr(args); X rplacd(args,tmp); X } X X /* add the slotname to the %make-xxx argument list */ X tmp = cons(slotname,NIL); X if ((body = *pbody) == NIL) X *pbody = tmp; X else { X while (cdr(body) != NIL) X body = cdr(body); X rplacd(body,tmp); X } X X /* restore the stack */ X xlpopn(4); X} X X/* updateslot - update a slot definition */ XLOCAL updateslot(args,slotname,defexpr) X LVAL args,slotname,defexpr; X{ X LVAL tmp; X for (; consp(args); args = cdr(args)) X if (slotname == car(car(args))) { X if (defexpr != NIL) { X xlsave1(tmp); X tmp = newclosure(NIL,s_lambda,xlenv,xlfenv); X setbody(tmp,cons(defexpr,NIL)); X tmp = cons(tmp,NIL); X defexpr = tmp; X xlpop(); X } X rplaca(cdr(car(args)),defexpr); X break; X } X if (args == NIL) X xlerror("unknown slot name",slotname); X} END_OF_FILE if test 12885 -ne `wc -c <'src/xlisp/xcore/c/xlstruct.c'`; then echo shar: \"'src/xlisp/xcore/c/xlstruct.c'\" unpacked with wrong size! fi # end of 'src/xlisp/xcore/c/xlstruct.c' fi echo shar: End of archive 6 $of 16$. cp /dev/null ark6isdone MISSING="" for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 ; do if test ! -f ark${I}isdone ; then MISSING="${MISSING} ${I}" fi done if test "${MISSING}" = "" ; then echo You have unpacked all 16 archives. rm -f ark[1-9]isdone ark[1-9][0-9]isdone else echo You still need to unpack the following archives: echo " " ${MISSING} fi ## End of shell archive. exit 0